home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Night Owl 9
/
Night Owl CD-ROM (NOPV9) (Night Owl Publisher) (1993).ISO
/
020a
/
pc_set.zip
/
PC-SETUP.BAS
next >
Wrap
BASIC Source File
|
1993-01-29
|
40KB
|
1,071 lines
'********** PC-SETUP.BAS - PC Magazine Install Utility
'Copyright (c) 1992 Ethan Winer
'Note: If you run this program in the QB editor the ExeName function will
'return the directory that QB.EXE was run from, which is not necessarily the
'current directory. In that case you may have to enter the directory name
'where your various .ZIP files reside for PC-SETUP to find them.
'
'If you are using Crescent's P.D.Q. you must search for all each call to the
'Interrupt routine, and change it as shown in the accompanying comments. You
'can then compile and link this program for the smallest size possible as
'follows:
'
' bc pc-setup /o/s;
' link /nod/noe/packc/far/ex _
' pc-setup _noread _noval _noerror _cprint , , nul , [basic7] pdq;
' exe2com pc-setup (optional)
' del pc-setup.exe (optional)
' ren pc-setup.com pc-setup.exe (optional)
'
'The PC-SETUP.EXE program supplied via PC MagNet was created with QuickBASIC
'4.5 using the five steps shown above.
DEFINT A-Z
'---- BASIC SUB and FUNCTION procedures in this program file
'
DECLARE SUB CopyFile (Source$)
DECLARE SUB DrawBox (ULRow, ULCol, LRRow, LRCol, Style)
DECLARE SUB DrawScreen ()
DECLARE SUB Editor (Text$, Row, LeftCol, Length, KeyCode)
DECLARE SUB EarlyEnd ()
DECLARE SUB ErrorEnd (Message$)
DECLARE SUB MidCharS (Work$, Position, NewChar)
DECLARE SUB ReadNames (Spec$, Array$())
DECLARE SUB SelectFiles (FileNames$(), Choice, ExitCode)
DECLARE SUB SetDrive (Drive$)
DECLARE SUB StuffBuf (Work$)
DECLARE FUNCTION ChangeDir% (DirName$)
DECLARE FUNCTION DOSVersion% ()
DECLARE FUNCTION Execute% (FileName$, Parameter$)
DECLARE FUNCTION ExeName$ ()
DECLARE FUNCTION FileCount% (FileSpec$, DirFlag)
DECLARE FUNCTION GetComment$ (FileName$)
DECLARE FUNCTION GetDir$ ()
DECLARE FUNCTION GetDrive% ()
DECLARE FUNCTION IntVal% (Work$)
DECLARE FUNCTION MakeDir% (DirName$)
DECLARE FUNCTION MidChar% (Work$, Position)
DECLARE FUNCTION Prompt% (Which)
DECLARE FUNCTION SourceDir$ ()
'Define the TYPE and other shared variables needed for using CALL InterruptX.
'
TYPE RegType
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
BP AS INTEGER
SI AS INTEGER
DI AS INTEGER
Flags AS INTEGER
DS AS INTEGER
ES AS INTEGER
END TYPE
DIM SHARED Regs AS RegType
TYPE DTAType 'used by find first/next service
Reserved AS STRING * 21 'reserved for use by DOS
Attribute AS STRING * 1 'the file's attribute
FileTime AS STRING * 2 'the file's time
FileDate AS STRING * 2 'the file's date
FileSize AS LONG 'the file's size
FileName AS STRING * 13 'the file's name
END TYPE
DIM SHARED DTA AS DTAType
DIM SHARED DOS 'so the DOS procedures can get at it
DIM SHARED ZBuffer AS STRING * 80 'holds ASCIIZ copies of DOS strings
DIM SHARED One, Zero, Zero$ 'these save code when used in CALLs
DIM SHARED Temp, Temp$ 'these are reusable scratch variables
'---- Define some constants and variables, and colors based on display type.
'
CONST MaxFiles% = 19 'max. number of .ZIP files per disk
CONST DirLength% = 25 'length of dest. directory display
One = 1 'saves four bytes per use in a CALL
DOS = &H21 'also saves four bytes per use
Zero$ = CHR$(0) 'call CHR$() just once here
PadComment$ = SPACE$(36) 'holds each comment when printing
REDIM DirsMade$(1 TO 100) 'remembers directories we created
Bar$ = "╠" + STRING$(78, 205) + "╣" 'for the main screen separating bars
Msg$ = SPACE$(79) 'for messages on the bottom line
IF INSTR(UCASE$(COMMAND$), "/B") THEN MonoFlag = -1 '/b forces mono colors
NormFG = 11: NormBG = 7 'assume colors for a color display
HiFG = 11: HiBG = 4 'menu and default directory colors
MainFG = 10: MainBG = 1 'main screen and box FG and BG colors
CsrSize = 7 'color displays use 8 scan lines
DEF SEG = 0 'see if it's really a color display
MonoMon = (PEEK(&H463) = &HB4) 'if not, MonoMon now equals -1
IF MonoMon OR MonoFlag THEN 'it's monochrome or /b was used
NormFG = 7: NormBG = 0
HiFG = 15: HiBG = 0
MainFG = 0: MainBG = 7
IF MonoMon THEN CsrSize = 12 'mono displays use 13 scan lines
END IF
IF DOSVersion% < 300 THEN 'PC-SETUP requires DOS 3.0 or later
PRINT "DOS 3.0 or later required."
END
END IF
'---- Get the directory PC-SETUP was run from or prompt for it if needed, to
' ensure that there's at least one .ZIP file present to install.
'
InstPath$ = SourceDir$
DO
IF RIGHT$(InstPath$, 1) <> "\" THEN InstPath$ = InstPath$ + "\"
InstSpec$ = InstPath$ + "*.ZIP"
NumFiles = FileCount%(InstSpec$, Zero)
IF NumFiles THEN EXIT DO
PRINT "No .ZIP files were found."
INPUT "Enter the source directory or press Enter to end: ", InstPath$
IF LEN(InstPath$) = 0 THEN END
LOOP
IF FileCount%(InstPath$ + "PKUNZIP.EXE", Zero) = 0 THEN 'confirm PKUNZIP
PRINT "Can't find PKUNZIP." ' is available
END
END IF
IF MidChar%(InstPath$, 2) <> 58 THEN 'if there's no drive letter (:)
InstPath$ = CHR$(GetDrive%) + ":" + InstPath$ 'append the current drive
END IF
'---- See if they're installing more than one disk, and if so how many.
'
NumDisks = 1 'assume only one disk for now
NumDisksFile$ = InstPath$ + "NUMDISKS.*" 'concatenate these just once
IF FileCount%(NumDisksFile$, Zero) THEN
DIM NumDisks$(1 TO 1)
CALL ReadNames(NumDisksFile$, NumDisks$())
Temp = INSTR(NumDisks$(1), ".")
NumDisks = IntVal%(MID$(NumDisks$(1), Temp + 1))
END IF
'---- See if there's a DEFAULT.DIR file in the root directory of the first
' distribution disk, and if so read its contents. Here we're using
' FileCount to merely see if the file exists. If there's no DEFAULT.DIR
' file, default to current drive and directory. And if the current drive
' is A or B replace that with C.
'
SaveDir$ = CHR$(GetDrive%) + ":" + GetDir$ 'save this while we have it
DefaultDir$ = SaveDir$ 'now assign it as the default
Temp = ASC(DefaultDir$) 'avoid using ASC() twice
IF Temp = 65 OR Temp = 66 THEN 'don't default to A: or B:
CALL MidCharS(DefaultDir$, 1, 67) 'if A: or B:, substitute C:
END IF
DefaultDirFile$ = InstPath$ + "DEFAULT.DIR" 'concatenate these just once
IF FileCount%(DefaultDirFile$, Zero) THEN 'open the file if it exists
OPEN DefaultDirFile$ FOR INPUT AS #1
INPUT #1, DefaultDir$ 'read the default directory,
CLOSE ' trim and capitalize (UCASE$
DefaultDir$ = UCASE$(RTRIM$(LTRIM$(DefaultDir$))) ' is for cosmetics only)
END IF
'---- See if there's a PROGRAM.RUN file in the root directory of the first
' distribution disk, and if so read its contents.
'
RunFileName$ = InstPath$ + "PROGRAM.RUN" 'concatenate these just once
IF FileCount%(RunFileName$, Zero) THEN 'open the file if it exists
OPEN RunFileName$ FOR INPUT AS #1
INPUT #1, RunName$
CLOSE
RunName$ = RunName$ + CHR$(13) 'simulate pressing Enter
IF LEN(RunName$) > 15 THEN RunName$ = "" 'don't use name if too long
END IF
'---- This is the main installation loop that cycles through each diskette.
'
FOR Disk = 1 TO NumDisks
'---- See how many .ZIP files there are on the current disk, and limit the
' number we'll handle to MaxFiles% if there are more than that. Then
' draw/redraw the main screen.
'
NumFiles = FileCount%(InstSpec$, Zero)
IF NumFiles > MaxFiles% THEN NumFiles = MaxFiles%
CALL DrawScreen
'---- Read the .ZIP file names and display them in a vertical menu. Then
' read any default directories (if present) within each .ZIP file's
' comment, and display them in the destination directory fields. For
' each .ZIP file that doesn't have a corresponding default directory
' in the comment, use the contents of the main DEFAULT.DIR file found
' in the root directory of the disk.
'
REDIM ZIPName$(1 TO NumFiles)
REDIM DestDir$(1 TO NumFiles)
REDIM Comment$(1 TO NumFiles)
CALL ReadNames(InstSpec$, ZIPName$())
FOR X = 1 TO NumFiles 'look at each .ZIP file comment
DestDir$(X) = SPACE$(DirLength%) 'create a string to hold the dest dir
LSET DestDir$(X) = DefaultDir$ 'assume none, use the global default
Comment$(X) = GetComment$(InstPath$ + ZIPName$(X))
Temp = INSTR(Comment$(X), "■") 'see if a directory was given
IF Temp THEN 'there is a directory for this file
LSET DestDir$(X) = UCASE$(MID$(Comment$(X), Temp + 1)) 'dir is on right
Comment$(X) = LEFT$(Comment$(X), Temp - 1) 'and comment on left
END IF
NEXT
FOR X = 1 TO NumFiles 'add leading blanks to make room
ZIPName$(X) = " " + ZIPName$(X) ' for the CHR$(251) check marks
IF RIGHT$(Comment$(X), 1) = "√" THEN 'they want this file checked
CALL MidCharS(ZIPName$(X), 2, 251) 'so check it in the file list box
Comment$(X) = LEFT$(Comment$(X), LEN(Comment$(X)) - 1)
END IF
LSET PadComment$ = Comment$(X) 'display the directories and comments
COLOR NormFG, NormBG 'while we're here
LOCATE X + 4, 2: PRINT DestDir$(X);
LOCATE X + 4, 44: PRINT PadComment$;
NEXT
DO 'let the user select the files
CALL SelectFiles(ZIPName$(), Choice, ExitCode)
IF ExitCode = 9 THEN 'they pressed Tab
COLOR MainFG, MainBG
LOCATE 25, 2
PRINT SPC(30); "Tab: Select .ZIP files F2: Begin Esc: Quit";
DO
CALL Editor(DestDir$(Choice), Choice + 4, 2, 25, ExitCode)
SELECT CASE ExitCode 'how did the terminate editing?
CASE -80 'Down Arrow
Choice = Choice + 1 'wrap around if they go past the end
IF Choice > NumFiles THEN Choice = 1
CASE -72 'Up Arrow
Choice = Choice - 1 'wrap to the end if they go before 1
IF Choice < 1 THEN Choice = NumFiles
CASE 27 'Escape
CALL EarlyEnd
CASE -60 'F2
ExitCode = -60 'tell SelectFiles to come right back
EXIT DO ' so we can exit both levels of DO
CASE ELSE
EXIT DO 'anything else returns to SelectFiles
END SELECT
LOOP
ELSEIF ExitCode = -60 THEN 'F2
ExitCode = 0 'prevent unwanted recursion across
EXIT DO ' multiple disks
ELSEIF ExitCode = 27 THEN 'Escape
CALL EarlyEnd
END IF
LOOP
'---- Install the selected files to the specified destination directories.
' For each file that is tagged, either change to the appropriate drive
' and directory, or ensure that we're back to the original path.
'
FOR X = 1 TO NumFiles 'for each .ZIP file present
IF MidChar%(ZIPName$(X), 2) = 251 THEN 'if it's tagged to install
IF X = 1 THEN RunProg = -1 'use PROGRAM.RUN only if first
' file is being installed
COLOR MainFG, MainBG 'for the status message below
CLS
LSET Msg$ = "Installing" + RTRIM$(MID$(ZIPName$(X), 3)) + "..."
COLOR HiFG
PRINT Msg$ 'advise the user as to progress
COLOR MainFG
DestPath$ = RTRIM$(DestDir$(X)) 'work with a copy of the path
IF MidChar%(DestPath$, 2) = 58 THEN 'if a drive was used (58 = ":")
CALL SetDrive(DestPath$) 'change to that drive
IF GetDrive% <> ASC(DestPath$) THEN 'no such drive
CALL ErrorEnd("Drive " + LEFT$(DestPath$, 2) + " invalid")
END IF
ELSE
CALL SetDrive(DefaultDir$) 'else switch to default drive
END IF
'strip off possible trailing "\" unless it refers to the root directory
IF RIGHT$(DestPath$, 1) = "\" THEN
Temp = LEN(DestPath$)
IF Temp > 1 AND RIGHT$(DestPath$, 2) <> ":\" THEN
DestPath$ = LEFT$(DestPath$, Temp - 1)
END IF
END IF
Temp = -1 'assume directory now exists
IF LEN(DestPath$) THEN 'if a directory name was given
IF RIGHT$(DestPath$, 1) <> "\" THEN 'and it's not a root directory
IF FileCount%(DestPath$, -1) = 0 THEN 'does the directory exist?
IF MakeDir%(DestPath$) THEN 'no, so first try to create it
CALL ErrorEnd("Cannot create " + DestPath$)
END IF
Temp = 0 'it can't possibly have files
DirsWeMade = DirsWeMade + 1 'show we created another one
DirsMade$(DirsWeMade) = DestPath$ 'and remember its name
END IF
FOR Y = 1 TO DirsWeMade 'see if we made this directory
IF DestPath$ = DirsMade$(Y) THEN 'yes, so there's no need to
Temp = 0 ' warn about overwriting files
EXIT FOR
END IF
NEXT
END IF
IF ChangeDir%(DestPath$) THEN 'then try to change to it
CALL ErrorEnd("Unable to access " + DestPath$)
END IF
END IF
PKCmd$ = "-o " 'assume they want to be warned
IF Temp THEN 'this directory existed
IF Prompt%(Zero) THEN 'ask if they want to be warned
PKCmd$ = "" ' to overwrite existing files
END IF ' without further prompting and
END IF ' use appropriate command if so
IF NOT PKCopied THEN 'copy PKUNZIP first time only
PKCopied = -1 'flag that we did it already
CALL CopyFile(InstPath$) 'show where PKUNZIP.EXE is
PKDir$ = RTRIM$(DestDir$(X)) 'remember where we put it!
IF LEN(PKDir$) = 0 THEN PKDir$ = DefaultDir$ 'use default dir if none
Temp = ASC(RIGHT$(PKDir$, 1)) 'check the right-most character
IF Temp <> 58 AND Temp <> 92 THEN 'if not a colon or backslash
PKDir2$ = "\" ' create a trailing "\"
END IF ' which is appended below
END IF
'---- Install all of the files contained in this .ZIP file and check
' for an errors returned by either DOS or PKUNZIP. Execute returns
' positive error values if PKUNZIP was run okay but it returned an
' error via the DOS Errorlevel. If DOS itself reports an error
' (perhaps there wasn't enough memory to run the program) Execute
' returns the DOS error value as a negative number. Error 8 is the
' DOS "Out of memory" error.
'
Temp = Execute%(PKDir$ + PKDir2$ + "PKUNZIP.EXE", PKCmd$ + InstPath$ + RTRIM$(MID$(ZIPName$(X), 4)))
IF Temp THEN
Temp$ = "PKUNZIP reports Error" + STR$(Temp)
IF Temp < 0 THEN Temp$ = "Out of memory"
CALL ErrorEnd(Temp$)
END IF
IF INKEY$ = CHR$(27) THEN 'allow aborting by pressing Escape
CALL EarlyEnd
END IF
END IF
NEXT
IF Disk < NumDisks THEN 'if there are more disks to install
LOCATE 25, 2 'prompt to insert the next disk
LSET Msg$ = "Insert the next disk and press any key when ready"
COLOR MainFG, MainBG
PRINT Msg$;
LOCATE , 52
DO: LOOP WHILE LEN(INKEY$) 'first clear any pending keys
DO: LOOP UNTIL LEN(INKEY$) 'then wait for a keypress
CALL SetDrive(SaveDir$) 'return to the current drive and its
Temp = ChangeDir%(SaveDir$) ' current directory before going on
END IF
NEXT Disk
'---- Report success and run the specified program (StuffBuf ignores a null
' string argument.
'
COLOR 7, 0: CLS
LOCATE 13, 30: PRINT "Installation complete!"
LOCATE 22, 1, 1
CALL SetDrive(PKDir$) 'change to the first drive and
Temp = ChangeDir%(PKDir$) ' directory we installed to
KILL "PKUNZIP.EXE" 'delete the copy of PKUNZIP.EXE there
IF RunProg THEN CALL StuffBuf(RunName$) 'stuff the buffer if appropriate
END 'and end
FUNCTION ChangeDir% (DirName$) 'returns 0 if Okay, -1 if an error
ZBuffer$ = DirName$ + Zero$ 'make an ASCIIZ string
Regs.AX = &H3B00 'DOS change directory service
Regs.DX = VARPTR(ZBuffer$) 'show DOS where ZBuffer$ is
CALL Interrupt(DOS, Regs, Regs) 'call DOS
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
IF Regs.Flags AND 1 THEN 'must be an invalid path
ChangeDir% = -1 'return -1 as an error
END IF
END FUNCTION
SUB CopyFile (Source$) STATIC 'copies PKUNZIP.EXE
Temp$ = Source$ + "PKUNZIP.EXE"
IF FileCount%(Temp$, Zero) THEN
OPEN Temp$ FOR BINARY AS #1 'open the input file if it exists
ELSE 'if we can't find it, bag out with
CALL ErrorEnd("Can't find PKUNZIP.EXE") ' an error message
END IF
OPEN "PKUNZIP.EXE" FOR BINARY AS #2 'now open the target file
Temp$ = SPACE$(LOF(1)) 'make a buffer to hold PKUNZIP.EXE
GET #1, , Temp$ 'read the source file
PUT #2, , Temp$ 'write it to the destination
CLOSE 'all done here
END SUB
FUNCTION DOSVersion% STATIC 'returns DOS version * 100 (3.30 = 330)
Regs.AX = &H3000 'DOS get DOS version service
CALL Interrupt(DOS, Regs, Regs)
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
'combine the major version in AL and the minor in AH
DOSVersion% = (Regs.AX AND 255) * 100 + (Regs.AX \ 256)
END FUNCTION
SUB DrawBox (ULRow, ULCol, LRRow, LRCol, Style) STATIC
Length = LRCol - ULCol + 1 'calculate this just once
IF Style = 1 THEN
LineType = 196
VertBar$ = "│"
ELSE
LineType = 205
VertBar$ = "║"
END IF
FOR X = ULRow TO LRRow 'first draw the walls
LOCATE X, ULCol
Temp = 32
IF X = ULRow OR X = LRRow THEN Temp = LineType
PRINT VertBar$; STRING$(Length - 2, Temp); VertBar$;
NEXT
IF Style = 1 THEN 'then draw the corners
LOCATE ULRow, ULCol: PRINT "┌";
LOCATE ULRow, LRCol: PRINT "┐";
LOCATE LRRow, ULCol: PRINT "└";
LOCATE LRRow, LRCol: PRINT "┘";
ELSE
LOCATE ULRow, ULCol: PRINT "╔";
LOCATE ULRow, LRCol: PRINT "╗";
LOCATE LRRow, ULCol: PRINT "╚";
LOCATE LRRow, LRCol: PRINT "╝";
END IF
END SUB
SUB DrawScreen STATIC
SHARED MainFG, MainBG, Bar$
'---- Draw the title screen and surrounding boxes.
'
COLOR MainFG, MainBG: CLS : LOCATE , , 0
CALL DrawBox(One, One, 24, 80, 2)
LOCATE 2, 24: PRINT "PC Magazine's PC-SETUP Version 1.00"
LOCATE 3, 1: PRINT Bar$
CALL DrawBox(3, 27, 24, 43, One)
LOCATE 3, 27: PRINT "╤═══════════════╤";
LOCATE 24, 27: PRINT "╧═══════════════╧";
LOCATE 4, 3: PRINT "Destination Directories";
LOCATE , 31: PRINT "ZIP Files";
LOCATE , 58: PRINT "Comments"
LOCATE 25, 2
PRINT "Up/Down/Space: Select files Tab: Edit destination F2: Begin Esc: Quit";
END SUB
SUB EarlyEnd STATIC
IF Prompt%(One) THEN
COLOR 7, 0
CLS
LOCATE 24, , 1
END
END IF
LOCATE , , 0
END SUB
SUB Editor (Text$, Row, LeftCol, Length, KeyCode) STATIC
SHARED HiFG, HiBG, NormFG, NormBG, MonoMon, CsrSize
'----- Work with a temporary copy.
Edit$ = SPACE$(Length)
LSET Edit$ = Text$
'----- See where to begin editing and print the string.
TxtPos = 1
LOCATE Row, LeftCol, 1, CsrSize - 1, CsrSize
COLOR HiFG, HiBG
PRINT Edit$;
'----- This is the main loop for handling key presses.
DO
LOCATE , LeftCol + TxtPos - 1, 1
DO
Ky$ = UCASE$(INKEY$)
LOOP UNTIL LEN(Ky$) 'wait for a keypress
IF LEN(Ky$) = 1 THEN 'create a key code
KeyCode = ASC(Ky$) 'regular character key
ELSE 'extended key
KeyCode = -ASC(RIGHT$(Ky$, 1))
END IF
'----- Branch according to the key pressed.
SELECT CASE KeyCode
'----- Backspace: decrement the pointer and the
' cursor, and ignore if in the first column.
CASE 8
TxtPos = TxtPos - 1
IF TxtPos < 1 THEN TxtPos = 1
LOCATE , LeftCol + TxtPos - 1, 0
IF TxtPos > 0 THEN
IF InsStatus THEN
MID$(Edit$, TxtPos) = MID$(Edit$, TxtPos + 1) + " "
ELSE
MID$(Edit$, TxtPos) = " "
END IF
PRINT MID$(Edit$, TxtPos);
END IF
'----- Enter or Escape: this block is optional in
' case you want to handle these separately.
CASE 13, 27
EXIT DO 'exit the subprogram
'----- Letter keys: turn off the cursor to hide
' the printing, handle Insert mode as needed.
CASE 32 TO 254
LOCATE , , 0
IF InsStatus THEN 'expand the string
MID$(Edit$, TxtPos) = Ky$ + MID$(Edit$, TxtPos)
PRINT MID$(Edit$, TxtPos);
ELSE 'else insert character
MID$(Edit$, TxtPos) = Ky$
PRINT Ky$;
END IF
TxtPos = TxtPos + 1 'update position counter
IF TxtPos > Length THEN TxtPos = Length
'----- Left arrow: decrement the position counter.
CASE -75
TxtPos = TxtPos - 1
IF TxtPos < 1 THEN TxtPos = 1
'----- Right arrow: increment position counter.
CASE -77
TxtPos = TxtPos + 1
IF TxtPos > Length THEN TxtPos = Length
'----- Home: jump to the first character position.
CASE -71
TxtPos = 1
'----- End: search for the last non-blank, and
' make that the current editing position.
CASE -79
FOR N = Length TO 1 STEP -1
IF MID$(Edit$, N, 1) <> " " THEN EXIT FOR
NEXT
TxtPos = N + 1
IF TxtPos > Length THEN TxtPos = Length
'----- Insert key: toggle the Insert state and
' adjust the cursor size.
CASE -82
InsStatus = NOT InsStatus
IF InsStatus THEN
LOCATE , , , CsrSize \ 2, CsrSize
ELSE
LOCATE , , , CsrSize - 1, CsrSize
END IF
'----- Delete: delete the current character and
' reprint what remains in the string.
CASE -83
MID$(Edit$, TxtPos) = MID$(Edit$, TxtPos + 1) + " "
LOCATE , , 0
PRINT MID$(Edit$, TxtPos);
'---- All other keys: exit the subprogram
CASE ELSE
EXIT DO
END SELECT
'----- Loop until the cursor moves out of the field.
LOOP
LSET Edit$ = LTRIM$(Edit$) 'trim and reprint the text in the normal
LOCATE , 2 ' color before returning
COLOR NormFG, NormBG
PRINT Edit$
Text$ = RTRIM$(Edit$) 'now trim what's on the right too
END SUB
SUB ErrorEnd (Message$) STATIC
COLOR 7, 0
CLS
LOCATE 13, 34 - LEN(Message$) \ 2, 1
PRINT "Error: "; Message$; ", ending."
END
END SUB
FUNCTION Execute% (Program$, Parameter$) STATIC
'---- Prepare the program name and parameter strings for processing. DOS
' requires that the parameter string hold the length of the parameter
' text, followed by the parameter text, and then followed by a CHR$(13)
' Enter byte. The parameter block holds two CHR$(0) bytes followed by
' the address and segment of the parameter string.
'
DIM Block AS STRING * 14 'this is the DOS parameter block
DIM Parm AS STRING * 50 'and this is the actual parameter text
ZBuffer$ = Program$ + Zero$ 'make an ASCIIZ string for DOS
LSET Parm$ = CHR$(LEN(Parameter$)) + Parameter$ + CHR$(13)
LSET Block$ = Zero$ + Zero$ + MKI$(VARPTR(Parm$)) + MKI$(VARSEG(Parm$))
Dummy& = SETMEM(-500000) 'free up memory for PKUNZIP to run
Regs.AX = &H4B00 'DOS load/execute function
Regs.DX = VARPTR(ZBuffer$) 'offset of program name into DX
Regs.ES = VARSEG(Block$) 'segment of parameter block into ES
Regs.BX = VARPTR(Block$) 'offset of parameter block into BX
Regs.DS = -1 'set DS to BASIC's segment
CALL InterruptX(DOS, Regs, Regs) 'execute it as subordinate process
'CALL InterruptX(DOS, Regs) 'use this with P.D.Q.
IF Regs.Flags AND 1 THEN 'DOS had an error trying to run PKUNZIP
Execute% = -Regs.AX 'set function value to exit code
EXIT FUNCTION
END IF
Regs.AX = &H4D00 'retrieve subordinate process code
CALL Interrupt(DOS, Regs, Regs)
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
Execute% = Regs.AX 'set function value to exit code
Dummy& = SETMEM(500000) 'reclaim the memory reliquished eariler
END FUNCTION
FUNCTION ExeName$ STATIC
'Returns the name of the currently running program; requires DOS 3.0 +
'---- DOS Interrupt &H21 service &H62 returns the PSP segment in BX
Regs.AX = &H6200
CALL Interrupt(DOS, Regs, Regs)
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
'---- The environment segment is at address &H2C/&H2D in PSP segment
DEF SEG = Regs.BX
DEF SEG = PEEK(&H2C) + PEEK(&H2D) * 256
'---- Search the environment segment for two zero bytes in a row. A count
' word (which we skip over) follows that, and the program name follows
' the count word.
Byte = 0
DO
IF PEEK(Byte) = 0 THEN 'this is zero
IF PEEK(Byte + 1) = 0 THEN 'this is too
Byte = Byte + 2 'so skip both
EXIT DO 'all done
END IF
END IF 'else,
Byte = Byte + 1 'keep looking
LOOP
IF PEEK(Byte) = 1 THEN 'if this count byte = 1
Byte = Byte + 2 'the name follows
DO WHILE PEEK(Byte) 'up to another zero
Tmp$ = Tmp$ + CHR$(PEEK(Byte)) 'this is a different Tmp$ on purpose
Byte = Byte + 1
LOOP
ExeName$ = Tmp$ 'assign the function output
END IF
END FUNCTION
FUNCTION FileCount% (FileSpec$, DirFlag)
Regs.DX = VARPTR(DTA) 'set new DTA address
Regs.AX = &H1A00 'specify service 1Ah
CALL Interrupt(DOS, Regs, Regs) 'DOS set DTA service
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
Temp = 0 'clear the counter
ZBuffer$ = FileSpec$ + Zero$ 'make an ASCIIZ string
Regs.DX = VARPTR(ZBuffer$) 'the file spec address
Regs.CX = 39 'file attribute = all files
IF DirFlag THEN Regs.CX = 39 OR 16 'include directories too
Regs.AX = &H4E00 'find first matching name service
DO
CALL Interrupt(DOS, Regs, Regs) 'see if there's a match
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
IF Regs.Flags AND 1 THEN EXIT DO 'no more files
IF DirFlag THEN 'do we want directories?
IF ASC(DTA.Attribute) AND 16 THEN 'yes, but is this a directory?
IF ASC(DTA.FileName) <> 46 THEN 'filter "." and ".." (46 = period)
Temp = Temp + 1 'we got another directory name
END IF
END IF
ELSE
Temp = Temp + 1 'we got another file name
END IF
Regs.AX = &H4F00 'find next name service
LOOP
FileCount% = Temp 'assign the function output
END FUNCTION
FUNCTION GetComment$ (Zip$) STATIC 'read comment from file named in Zip$
ZipID$ = "PK" + CHR$(5) + CHR$(6) 'this identifies a file as a ZIP file
OPEN RTRIM$(Zip$) FOR BINARY AS #1 'open the .ZIP file
FileSize& = LOF(1) 'get and save its length
BufferSize = 3072 'the default header size
IF BufferSize > FileSize& THEN BufferSize = FileSize&
Temp$ = SPACE$(BufferSize) 'make buffer to receive ZIP header
GET #1, FileSize& - BufferSize + 1, Temp$
CLOSE
Temp = 0 'find the last occurrence of PK ID
DO
HeaderOffset = Temp 'remember where this one is
Temp = INSTR(Temp + 1, Temp$, ZipID$) 'find the next one
LOOP WHILE Temp 'until no more
IF HeaderOffset THEN 'if there's a comment, extract it
CommentLen = CVI(MID$(Temp$, HeaderOffset + 20, 2))
GetComment$ = MID$(Temp$, HeaderOffset + 22, CommentLen)
END IF
Temp$ = "" 'free up the memory
END FUNCTION
FUNCTION GetDir$ STATIC
Regs.AX = &H4700 'DOS get directory service
Regs.DX = 0 'the drive goes in DL, 0 = default
Regs.SI = VARPTR(ZBuffer$) 'show DOS where ZBuffer$ is
CALL Interrupt(DOS, Regs, Regs) 'call DOS
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
IF Regs.Flags AND 1 THEN 'must be an invalid drive
GetDir$ = ""
ELSE
Temp = INSTR(ZBuffer$, Zero$) 'find the zero byte, and return only
GetDir$ = "\" + LEFT$(ZBuffer$, Temp - 1) ' what precedes it
END IF
END FUNCTION
FUNCTION GetDrive% STATIC
Regs.AX = &H1900 'DOS Get Current Drive service
CALL Interrupt(DOS, Regs, Regs) 'call DOS
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
GetDrive% = (Regs.AX AND 255) + 65 'drive returned in AL as 0=A, 1=B...
END FUNCTION
FUNCTION IntVal% (Work$) STATIC
'IntVal is an integer-only VAL substitute that reduces .EXE size up to 10K
Length = LEN(RTRIM$(Work$))
Value = 0
FOR X = Length TO 1 STEP -1
Temp = MidChar%(Work$, X)
IF Temp > 47 AND Temp < 58 THEN
IF X = Length THEN
Value = Temp - 48
ELSE
Value = Value + (Temp - 48) * 10
END IF
END IF
NEXT
IntVal% = Value
END FUNCTION
FUNCTION MakeDir% (DirName$) STATIC
ZBuffer$ = DirName$ + Zero$ 'make an ASCIIZ string
Regs.AX = &H3900 'DOS create directory service
Regs.DX = VARPTR(ZBuffer$) 'show DOS where ZBuffer$ is
CALL Interrupt(DOS, Regs, Regs) 'call DOS
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
IF Regs.Flags AND 1 THEN 'must be an invalid drive or bad name
MakeDir% = -1 'return -1 as an error
END IF
END FUNCTION
FUNCTION MidChar% (Work$, Position)
IF Position <= LEN(Work$) THEN
MidChar% = ASC(MID$(Work$, Position, 1))
ELSE
MidChar% = -1
END IF
END FUNCTION
SUB MidCharS (Work$, Position, NewChar) STATIC
MID$(Work$, Position, 1) = CHR$(NewChar)
END SUB
FUNCTION Prompt% (Which) STATIC
SHARED HiFG, HiBG, MonoMon, CsrSize, DestPath$
DEF SEG = &HB800 'assume a color display
IF MonoMon THEN DEF SEG = &HB000 'nope, use the mono video segment
REDIM SaveScrn(10 TO 13, 14 TO 66) 'this saves the underlying screen
FOR Row = 10 TO 13 'Here, Row and Col are zero-based
FOR Col = 14 TO 66
Temp = Row * 160 + Col * 2 'calculate the address just once
SaveScrn(Row, Col) = PEEK(Temp) + 256 * PEEK(Temp + 1)
NEXT
NEXT
COLOR HiFG, HiBG
CALL DrawBox(11, 15, 14, 67, One) 'draw the surrounding box
IF Which THEN 'we were called from EarlyEnd
LOCATE 12, 31 'show this directory name
PRINT "Are you sure you want"; 'print the prompt message
LOCATE 13, 29, 1, CsrSize - 1, CsrSize
PRINT "to quit installing? (Y/N) ";
ELSE 'prompt if okay to overwrite files
LOCATE 12, 17 'show this directory name
PRINT "Installing to "; DestPath$ 'print the prompt message
LOCATE 13, 17, 1, CsrSize - 1, CsrSize
PRINT "Prompt before overwriting existing files? (Y/N) ";
END IF
DO 'wait for Yes or No (only)
Temp$ = UCASE$(INKEY$)
LOOP UNTIL INSTR(" YN", Temp$) > 1
Prompt% = 0 'assume the answer is No
IF Temp$ = "Y" THEN Prompt% = -1 'they answered Yes
FOR Row = 10 TO 13 'now restore the screen
FOR Col = 14 TO 66 'as above
Temp = Row * 160 + Col * 2
POKE Temp, SaveScrn(Row, Col) AND 255
POKE Temp + 1, SaveScrn(Row, Col) \ 256
NEXT
NEXT
ERASE SaveScrn
LOCATE 2 'put cursor at the top of the screen
END FUNCTION
SUB ReadNames (Spec$, Array$()) STATIC 'reads file names into an array
ZBuffer$ = Spec$ + Zero$ 'make an ASCIIZ string of the spec
CurFile = 0 'zero out the file counter
Regs.DX = VARPTR(ZBuffer$) 'the file spec address
Regs.CX = 39 'file attribute = all files
Regs.AX = &H4E00 'find first matching name service
DO
CALL Interrupt(DOS, Regs, Regs) 'see if there's a match
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
IF Regs.Flags AND 1 THEN EXIT DO 'no more files
CurFile = CurFile + 1 'we found another file name
Array$(CurFile) = SPACE$(12) 'create the string to hold it
Temp$ = DTA.FileName 'assign the name
Temp = INSTR(Temp$, Zero$) 'find the terminating zero byte
LSET Array$(CurFile) = LEFT$(Temp$, Temp - 1) 'keep only what precedes it
Regs.AX = &H4F00 'find the next name
LOOP
END SUB
SUB SelectFiles (FileNames$(), Choice, ExitCode) STATIC
SHARED NumFiles, NormFG, NormBG, HiFG, HiBG, MainFG, MainBG
IF ExitCode = -60 THEN EXIT SUB 'we got here via F2 pressed in Editor
COLOR MainFG, MainBG 'first display all of the choices
LOCATE 25, 2 'and update the status line
PRINT "Up/Down/Space: Select files Tab: Edit destination F2: Begin Esc: Quit";
COLOR NormFG, NormBG
FOR Temp = 1 TO NumFiles
LOCATE 4 + Temp, 28, 0 'and turn off the cursor
PRINT FileNames$(Temp);
NEXT
IF Choice = 0 THEN Choice = 1 'start at element 1 if first time
IF Choice > UBOUND(FileNames$) THEN Choice = 1 'or if past the end
DO
LOCATE 4 + Choice, 28 'redraw current choice highlighted
COLOR HiFG, HiBG
PRINT FileNames$(Choice);
DO
KeyHit$ = INKEY$ 'see what they want to do
LOOP UNTIL LEN(KeyHit$) 'wait for a keypress
IF LEN(KeyHit$) = 1 THEN 'set ExitCode based on the type of
ExitCode = ASC(KeyHit$) 'key (extended or not) they pressed
ELSE
ExitCode = -ASC(MID$(KeyHit$, 2))
END IF
IF ExitCode = 32 THEN 'spacebar
IF MidChar%(FileNames$(Choice), 2) = 251 THEN 'if it's now checked
Temp = 32 'remove the check mark
ELSE
Temp = 251 'else add a check mark
END IF
CALL MidCharS(FileNames$(Choice), 2, Temp)
ExitCode = -80 'select the next file automatically
END IF
SELECT CASE ExitCode
CASE -80 'Down Arrow
GOSUB Deselect
Choice = Choice + 1
IF Choice > NumFiles THEN Choice = 1
CASE -79 'End key
GOSUB Deselect
Choice = NumFiles
CASE -72 'Up Arrow
GOSUB Deselect
Choice = Choice - 1
IF Choice = 0 THEN Choice = NumFiles
CASE -71 'Home
GOSUB Deselect
Choice = 1
CASE -60 'F2
EXIT SUB
CASE 27 'Escape
EXIT SUB
CASE 9 'Tab
LOCATE Choice + 4, 33
GOSUB Deselect
EXIT SUB
CASE ELSE 'this is needed for QB 4.0 only
END SELECT
LOOP
Deselect: 're-paint the current choice, so it
LOCATE Choice + 4, 28 ' won't appear active
COLOR NormFG, NormBG
PRINT FileNames$(Choice);
RETURN
END SUB
SUB SetDrive (Drive$) STATIC
Regs.AX = &HE00 'DOS Set Drive service in AH
Regs.DX = ASC(UCASE$(Drive$)) - 65 'DL = 0 for A:, 1 for B:, and so on
CALL Interrupt(DOS, Regs, Regs) 'see if there's a match
'CALL Interrupt(DOS, Regs) 'use this with P.D.Q.
END SUB
FUNCTION SourceDir$ STATIC
Temp$ = ExeName$ 'get the directory we're running from
FOR X = LEN(Temp$) TO 1 STEP -1 'isolate the drive letter and path
Temp = MidChar%(Temp$, X) ' (strip off the name PC-SETUP.EXE)
IF Temp = 58 OR Temp = 92 THEN 'look for a colon or a backslash
SourceDir$ = LEFT$(Temp$, X) 'by searching for ":" or "\" this will
EXIT FOR ' work even if the program is renamed
END IF
NEXT
END FUNCTION
SUB StuffBuf (Cmd$) STATIC
'----- Set the segment for poking, define the buffer head and tail, and
' then poke each character into the keyboard buffer.
Temp = LEN(Cmd$)
DEF SEG = 0
POKE &H41A, &H1E
POKE &H41C, &H1E + Temp * 2
FOR X = 1 TO Temp
POKE &H41C + X * 2, ASC(MID$(Cmd$, X))
NEXT
END SUB